home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / DEFSTRUC.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  8.4 KB  |  211 lines
  1. ; DEFSTRUC.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        DEFINE-STRUCTURE and Related Routines            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastave        Date: Aug 1985            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;
  23. ; - syntax is similar to DEFSTRUCT in Common Lisp
  24. ;
  25. ; Syntax : (DEFINE-STRUCTURE name slot1 slot2 ...)
  26. ;
  27. ; slots may be given default values by (slot1 init-val)
  28. ;
  29. ; e.g (DEFINE-STRUCTURE SHIP (X-VEL 0) Y-VEL)
  30. ;
  31. ; objects of this structure can be generated by using
  32. ; MAKE-SHIP -
  33. ;
  34. ; (MAKE-SHIP 'X-VEL 10)
  35. ;
  36. ; the predicate SHIP? can be used to check if an object is an
  37. ; instance of ship.
  38. ;
  39. ; (SHIP-X-VEL object) can be used to get the `x-vel' of the object,
  40. ; which is an instance of `ship'
  41. ;
  42. ; (SET! (SHIP-X-VEL object) 11) can be used to set the `x-vel' of the
  43. ;  object.
  44. ;
  45. ; single-inheritance : structures can inherit from other objects by
  46. ; using the INCLUDE option (similar to Common Lisp DEFSTRUCT)
  47. ;
  48. ; e.g. (DEFINE-STRUCTURE (SHIP (INCLUDE FLOATING-OBJECT)) slot ...)
  49. ;
  50.  
  51. ;                         Implementation Note
  52.  
  53. ; The Common Lisp definition requires that the slot initialization
  54. ; expressions be re-evaluated each time a MAKE-name operation is
  55. ; performed.  For consistency with the spirit of Scheme, these
  56. ; expressions should be evaluated in the lexical environment surrounding
  57. ; the DEFINE-STRUCTURE itself.  Thus, DEFINE-STRUCTURE must expand into
  58. ; at least one LAMBDA that `freezes' the initialization expressions.
  59. ; This is why %DEFINE-STRUCTURE expands into a BEGIN with an embedded
  60. ; closure for MAKE-name.  (This is important only if an initialization
  61. ; expression involves lexical references.)
  62.  
  63.  
  64. ; Global function used to generate predicates for all structures
  65.  
  66.  
  67. (define %structure-predicate                            ; %STRUCTURE-PREDICATE
  68.   (lambda (object tag)
  69.     (and (vector? object)
  70.          (positive? (vector-length object))
  71.          (member tag (vector-ref object 0))
  72.          #T)))
  73.  
  74.  
  75. ; %MAKE-STRUCTURE is used by all structures to create an instance
  76.  
  77.  
  78. (define %make-structure                                 ; %MAKE-STRUCTURE
  79.   (lambda (name constructor-name structure init-list)
  80.     (letrec ((slot-number
  81.               (lambda (slot slot-values)
  82.                 (apply-if (assq slot slot-values)
  83.                     cadr
  84.                     (error (string-append
  85.                                "Structure component unknown to "
  86.                                (symbol->string constructor-name))
  87.                            slot)))))
  88.       (let ((slots (getprop name '%SLOT-VALUES)))
  89.         (do ((structure structure)
  90.              (init-msg init-list (cddr init-msg)))
  91.             ((null? init-msg) structure)
  92.           (vector-set! structure
  93.                        (slot-number (car init-msg) slots)
  94.                        (cadr init-msg)))))))
  95.  
  96.  
  97. ; %DEFINE-STRUCTURE defines a structure with specified attributes.  This
  98. ; is the procedure that expands the macro DEFINE-STRUCTURE.
  99.  
  100.  
  101. (define %define-structure                               ; %DEFINE-STRUCTURE
  102.   (lambda (e)
  103.     (letrec
  104.      ((make-symbol                                      ; MAKE-SYMBOL
  105.        (lambda args
  106.          (string->symbol (apply string-append args))))
  107.  
  108.       (generate-slots-loop                              ; GENERATE-SLOTS-LOOP
  109.        (lambda (tail slots n)
  110.          (if (null? slots)
  111.              tail                                       ; 2/14/86
  112.              (generate-slots-loop
  113.                  (cons (if (atom? (car slots))
  114.                            (cons (car slots) (cons n '()))
  115.                            (cons (caar slots) (cons n (cadar slots))))
  116.                        tail)
  117.                  (cdr slots)
  118.                  (1+ n)))))
  119.  
  120.       (generate-slots                                   ; GENERATE-SLOTS
  121.        (lambda (include-struct slots)
  122.          (if include-struct
  123.              (let ((include-slots (getprop include-struct '%SLOT-VALUES)))
  124.                (generate-slots-loop include-slots
  125.                                     slots
  126.                                     (1+ (length include-slots))))
  127.              (generate-slots-loop '() slots 1))))
  128.  
  129.       (init-slots                                       ; INIT-SLOTS
  130.        (lambda (slots)
  131.          (let loop ((tail '())
  132.                     (slots slots))
  133.            (if (null? slots)
  134.                tail
  135.                (loop (if (member (cddar slots) '(() '()))
  136.                          tail
  137.                          (cons `(vector-set! %DS0001% ,(cadar slots)
  138.                                              ,(cddar slots))
  139.                                tail))
  140.                      (cdr slots))))))
  141.  
  142.       (access-macros-loop                               ; ACCESS-MACROS-LOOP
  143.        (lambda (name-string slots tail)
  144.          (if (null? slots)
  145.              (%reverse! tail)
  146.              (access-macros-loop
  147.                  name-string
  148.                  (cdr slots)
  149.                  (let ((name (make-symbol name-string "-"
  150.                                           (symbol->string (caar slots))))
  151.                        (index (cadar slots)))
  152.                    (cons `(define-integrable ,name
  153.                             (lambda (obj) (vector-ref obj ,index)))
  154.                          tail))))))
  155.  
  156.       (gen-access-macros                                ; GEN-ACCESS-MACROS
  157.        (lambda (name-string slot-names-pos)
  158.          (access-macros-loop name-string slot-names-pos '())))
  159.  
  160.       (gen-make-proc                                    ; GEN-MAKE-PROC
  161.        (lambda (name constructor-name slot-names-pos)
  162.          `(define ,constructor-name
  163.             (lambda %DS0002%
  164.               (let ((%DS0001% (make-vector ,(1+ (length slot-names-pos))
  165.                                            '())))
  166.                 (vector-set! %DS0001% 0 (getprop ',name '%TAG))
  167.                 ,@(init-slots slot-names-pos)
  168.                 (if (null? %DS0002%)
  169.                     %DS0001%
  170.                     (%make-structure ',name   ',constructor-name
  171.                                      %DS0001%   %DS0002%)))))))
  172.       )
  173.      (begin
  174.        (pcs-chk-length>= e e 2)
  175.        (let* ((name-options (cadr e))
  176.               (name (let ((n (if (atom? name-options)
  177.                                  name-options
  178.                                  (car name-options))))
  179.                       (pcs-chk-id e n)
  180.                       n))
  181.               (name-string (symbol->string name))
  182.               (constructor-name (make-symbol "MAKE-" name-string))
  183.               (predicate-name (make-symbol name-string "?"))
  184.               (include-struct
  185.                     (cond ((atom? name-options)
  186.                            '())
  187.                           ((and (pair? (cdr name-options))
  188.                                 (pair? (cadr name-options))
  189.                                 (eq? (car (cadr name-options)) 'INCLUDE)
  190.                                 (pair? (cdr (cadr name-options))))
  191.                            (let ((is (cadr (cadr name-options))))
  192.                              (pcs-chk-id e is)
  193.                              is))
  194.                           (else
  195.                            (syntax-error "Invalid option list" e))))
  196.               (slots (cddr e))
  197.               (slot-names-pos (generate-slots include-struct slots))
  198.               (tag (cons '#!STRUCTURE name))
  199.               (complex-tag (if include-struct
  200.                                (cons tag (getprop include-struct '%TAG))
  201.                                (list tag))))
  202.          `(begin
  203.             (putprop ',name ',complex-tag '%TAG)
  204.             (putprop ',name ',slot-names-pos '%SLOT-VALUES)
  205.             ,@(gen-access-macros name-string slot-names-pos)
  206.             (define ,predicate-name
  207.               (lambda (obj)
  208.                 (%structure-predicate obj ',tag)))
  209.             ,(gen-make-proc name constructor-name slot-names-pos)
  210.             ',name))))))
  211.